home *** CD-ROM | disk | FTP | other *** search
/ SGI Freeware 1999 August / SGI Freeware 1999 August.iso / dist / fw_xemacs.idb / usr / freeware / lib / xemacs-20.4 / lisp / w3 / url-news.el.z / url-news.el
Encoding:
Text File  |  1998-05-21  |  10.2 KB  |  311 lines
  1. ;;; url-news.el --- News Uniform Resource Locator retrieval code
  2. ;; Author: wmperry
  3. ;; Created: 1997/10/17 14:08:05
  4. ;; Version: 1.12
  5. ;; Keywords: comm, data, processes
  6.  
  7. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  8. ;;; Copyright (c) 1993-1996 by William M. Perry <wmperry@cs.indiana.edu>
  9. ;;; Copyright (c) 1996, 1997 Free Software Foundation, Inc.
  10. ;;;
  11. ;;; This file is not part of GNU Emacs, but the same permissions apply.
  12. ;;;
  13. ;;; GNU Emacs is free software; you can redistribute it and/or modify
  14. ;;; it under the terms of the GNU General Public License as published by
  15. ;;; the Free Software Foundation; either version 2, or (at your option)
  16. ;;; any later version.
  17. ;;;
  18. ;;; GNU Emacs is distributed in the hope that it will be useful,
  19. ;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
  20. ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  21. ;;; GNU General Public License for more details.
  22. ;;;
  23. ;;; You should have received a copy of the GNU General Public License
  24. ;;; along with GNU Emacs; see the file COPYING.  If not, write to the
  25. ;;; Free Software Foundation, Inc., 59 Temple Place - Suite 330,
  26. ;;; Boston, MA 02111-1307, USA.
  27. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  28. (require 'url-vars)
  29. (require 'url-parse)
  30.  
  31. (defgroup url-news nil
  32.   "News related options"
  33.   :group 'url)
  34.  
  35. (defcustom url-news-use-article-mode nil
  36.   "*Whether to use Gnus' article mode for displaying news articles."
  37.   :type 'boolean
  38.   :group 'url-news)
  39.  
  40. (defun url-format-news ()
  41.   (url-clear-tmp-buffer)
  42.   (insert "HTTP/1.0 200 Retrieval OK\r\n"
  43.        (save-excursion
  44.          (set-buffer nntp-server-buffer)
  45.          (buffer-string)))
  46.   (url-parse-mime-headers)
  47.   (let* ((from  (cdr (assoc "from" url-current-mime-headers)))
  48.      (qfrom (if from (url-insert-entities-in-string from) nil))
  49.      (subj  (cdr (assoc "subject" url-current-mime-headers)))
  50.      (qsubj (if subj (url-insert-entities-in-string subj) nil))
  51.      (org   (cdr (assoc "organization" url-current-mime-headers)))
  52.      (qorg  (if org (url-insert-entities-in-string org) nil))
  53.      (typ   (or (cdr (assoc "content-type" url-current-mime-headers))
  54.             "text/plain"))
  55.      (inhibit-read-only t)
  56.      (qgrps (mapcar 'car
  57.             (url-split
  58.              (url-insert-entities-in-string
  59.               (or (cdr (assoc "newsgroups" 
  60.                       url-current-mime-headers))
  61.                   ""))
  62.              "[ \t\n,]+")))
  63.      (qrefs (delete "" 
  64.             (mapcar
  65.              'url-insert-entities-in-string
  66.              (mapcar 'car
  67.                  (url-split
  68.                   (or (cdr (assoc "references" 
  69.                           url-current-mime-headers))
  70.                       "")
  71.                   "[ \t,\n<>]+")))))
  72.      (date  (cdr (assoc "date" url-current-mime-headers))))
  73.     (if (or (not (string-match "text/" typ))
  74.          (string-match "text/html" typ))
  75.      nil                ; Let natural content-type take over
  76.       (if (and (fboundp 'gnus-article-mode)
  77.            url-news-use-article-mode)
  78.       (progn
  79.         (kill-buffer (current-buffer))
  80.         (set-buffer (get-buffer-create "Emacs/W3 News"))
  81.         (erase-buffer)
  82.         (insert
  83.          (save-excursion
  84.            (set-buffer nntp-server-buffer)
  85.            (save-restriction
  86.          (widen)
  87.          (buffer-string))))
  88.         (let ((gnus-article-buffer (current-buffer))
  89.           (gnus-article-current (cons "url"
  90.                           (car (cdr (current-time))))))
  91.           (gnus-article-mode)
  92.           (run-hooks 'gnus-article-display-hook))
  93.         (goto-char (point-min))
  94.         (display-buffer (current-buffer)))
  95.     (insert "<html>\n"
  96.         " <head>\n"
  97.         "  <title>" qsubj "</title>\n"
  98.         "  <link rev=\"made\" href=\"mailto:" qfrom "\">\n"
  99.         " </head>\n"
  100.         " <body>\n"
  101.         "  <div>\n"
  102.         "   <h1 align=center>" qsubj "</h1>\n"
  103.         "   <p role=\"headers\">\n"
  104.         "    <b>From</b>: " qfrom "<br>\n"
  105.         "    <b>Newsgroups</b>: "
  106.         (mapconcat
  107.          (function
  108.           (lambda (grp)
  109.             (concat "<a href=\"" grp "\">" grp "</a>"))) qgrps ", ")
  110.         "<br>\n"
  111.         (if org
  112.             (concat
  113.              "    <b>Organization</b>: <i> " qorg "</i> <br>\n")
  114.           "")
  115.         "    <b>Date</b>: <date> " date "</date> <br>\n"
  116.         "   </p> <hr>\n"
  117.         (if (null qrefs)
  118.             ""
  119.           (concat
  120.            "   <p>References\n"
  121.            "    <ol>\n"
  122.            (mapconcat
  123.             (function
  124.              (lambda (ref)
  125.                (concat "     <li> <a href=\"" ref "\"> " 
  126.                    ref "</a></li>\n")))
  127.             qrefs "")
  128.            "    </ol>\n"
  129.            "   </p>\n"
  130.            "   <hr>\n"))
  131.         "   <ul plain>\n"
  132.         "    <li><a href=\"newspost:disfunctional\"> "
  133.         "Post to this group </a></li>\n"
  134.         "    <li><a href=\"mailto:" qfrom "\"> Reply to " qfrom
  135.         "</a></li>\n"
  136.         "   </ul>\n"
  137.         "   <hr>"
  138.         "   <pre>\n")
  139.     (let ((s (buffer-substring (point) (point-max))))
  140.       (delete-region (point) (point-max))
  141.       (insert (url-insert-entities-in-string s)))
  142.     (goto-char (point-max))
  143.     (setq url-current-mime-type "text/html"
  144.           url-current-mime-viewer (mm-mime-info url-current-mime-type nil 5))
  145.     (let ((x (assoc "content-type" url-current-mime-headers)))
  146.       (if x
  147.           (setcdr x "text/html")
  148.         (setq url-current-mime-headers (cons (cons "content-type"
  149.                                "text/html")
  150.                          url-current-mime-headers))))
  151.     (insert "\n"
  152.         "   </pre>\n"
  153.         "  </div>\n"
  154.         " </body>\n"
  155.         "</html>\n"
  156.         "<!-- Automatically generated by URL/" url-version
  157.         "-->")))))
  158.  
  159. (defun url-check-gnus-version ()
  160.   (require 'nntp)
  161.   (condition-case ()
  162.       (require 'gnus)
  163.     (error (setq gnus-version "GNUS not found")))
  164.   (if (or (not (boundp 'gnus-version))
  165.       (string-match "v5.[.0-9]+$" gnus-version)
  166.       (string-match "Red" gnus-version)
  167.       (string-match "Quassia" gnus-version))
  168.       nil
  169.     (url-warn 'url (concat
  170.             "The version of GNUS found on this system is too old and does\n"
  171.             "not support the necessary functionality for the URL package.\n"
  172.             "Please upgrade to version 5.x of GNUS.  This is bundled by\n"
  173.             "default with Emacs 19.30 and XEmacs 19.14 and later.\n\n"
  174.             "This version of GNUS is: " gnus-version "\n"))
  175.     (fset 'url-news 'url-news-version-too-old))
  176.   (fset 'url-check-gnus-version 'ignore))
  177.  
  178. (defun url-news-version-too-old (article)
  179.   (set-buffer (get-buffer-create url-working-buffer))
  180.   (setq url-current-mime-headers '(("content-type" . "text/html"))
  181.     url-current-mime-type "text/html")
  182.   (insert "<html>\n"
  183.       " <head>\n"
  184.       "  <title>News Error</title>\n"
  185.       " </head>\n"
  186.       " <body>\n"
  187.       "  <h1>News Error - too old</h1>\n"
  188.       "  <p>\n"
  189.       "   The version of GNUS found on this system is too old and does\n"
  190.       "   not support the necessary functionality for the URL package.\n"
  191.       "   Please upgrade to version 5.x of GNUS.  This is bundled by\n"
  192.       "   default with Emacs 19.30 and XEmacs 19.14 and later.\n\n"
  193.       "   This version of GNUS is: " gnus-version "\n"
  194.       "  </p>\n"
  195.       " </body>\n"
  196.       "</html>\n"))
  197.  
  198. (defun url-news-open-host (host port user pass)
  199.   (if (fboundp 'nnheader-init-server-buffer)
  200.       (nnheader-init-server-buffer))
  201.   (nntp-open-server host (list (string-to-int port)))
  202.   (if (and user pass)
  203.       (progn
  204.     (nntp-send-command "^.*\r?\n" "AUTHINFO USER" user)
  205.     (nntp-send-command "^.*\r?\n" "AUTHINFO PASS" pass)
  206.     (if (not (nntp-server-opened host))
  207.         (url-warn 'url (format "NNTP authentication to `%s' as `%s' failed"
  208.                    host user))))))
  209.  
  210. (defun url-news-fetch-article-number (newsgroup article)
  211.   (nntp-request-group newsgroup)
  212.   (nntp-request-article article))
  213.  
  214. (defun url-news-fetch-message-id (host port message-id)
  215.   (if (eq ?> (aref message-id (1- (length message-id))))
  216.       nil
  217.     (setq message-id (concat "<" message-id ">")))
  218.   (if (nntp-request-article message-id)
  219.       (url-format-news)
  220.     (set-buffer (get-buffer-create url-working-buffer))
  221.     (setq url-current-can-be-cached nil)
  222.     (insert "<html>\n"
  223.         " <head>\n"
  224.         "  <title>Error</title>\n"
  225.         " </head>\n"
  226.         " <body>\n"
  227.         "  <div>\n"
  228.         "   <h1>Error requesting article...</h1>\n"
  229.         "   <p>\n"
  230.         "    The status message returned by the NNTP server was:"
  231.         "<br><hr>\n"
  232.         "    <xmp>\n"
  233.         (nntp-status-message)
  234.         "    </xmp>\n"
  235.         "   </p>\n"
  236.         "   <p>\n"
  237.         "    If you If you feel this is an error, <a href=\""
  238.         "mailto:" url-bug-address "\">send me mail</a>\n"
  239.         "   </p>\n"
  240.         "  </div>\n"
  241.         " </body>\n"
  242.         "</html>\n"
  243.         "<!-- Automatically generated by URL v" url-version " -->\n"
  244.         )))
  245.  
  246. (defun url-news-fetch-newsgroup (newsgroup host)
  247.   (if (string-match "^/+" newsgroup)
  248.       (setq newsgroup (substring newsgroup (match-end 0))))
  249.   (if (string-match "/+$" newsgroup)
  250.       (setq newsgroup (substring newsgroup 0 (match-beginning 0))))
  251.  
  252.   ;; This saves a bogus 'Untitled' buffer by Emacs-W3
  253.   (kill-buffer url-working-buffer)
  254.   
  255.   ;; This saves us from checking new news if GNUS is already running
  256.   (if (or (not (get-buffer gnus-group-buffer))
  257.       (save-excursion
  258.         (set-buffer gnus-group-buffer)
  259.         (not (eq major-mode 'gnus-group-mode))))
  260.       (gnus))
  261.   (set-buffer gnus-group-buffer)
  262.   (goto-char (point-min))
  263.   (gnus-group-read-ephemeral-group newsgroup (list 'nntp host)
  264.                    nil
  265.                    (cons (current-buffer) 'browse)))
  266.   
  267. (defun url-news (article)
  268.   ;; Find a news reference
  269.   (url-check-gnus-version)
  270.   (let* ((urlobj (url-generic-parse-url article))
  271.      (host (or (url-host urlobj) url-news-server))
  272.      (port (or (url-port urlobj)
  273.            (cdr-safe (assoc "news" url-default-ports))))
  274.      (article-brackets nil)
  275.      (article (url-filename urlobj)))
  276.     (url-news-open-host host port (url-user urlobj) (url-password urlobj))
  277.     (cond
  278.      ((string-match "@" article)    ; Its a specific article
  279.       (url-news-fetch-message-id host port article))
  280.      ((string= article "")        ; List all newsgroups
  281.       (gnus)
  282.       (kill-buffer url-working-buffer))
  283.      (t                    ; Whole newsgroup
  284.       (url-news-fetch-newsgroup article host)))))
  285.  
  286. (defun url-nntp (url)
  287.   ;; Find a news reference
  288.   (url-check-gnus-version)
  289.   (let* ((urlobj (url-generic-parse-url url))
  290.      (host (or (url-host urlobj) url-news-server))
  291.      (port (or (url-port urlobj)
  292.            (cdr-safe (assoc "nntp" url-default-ports))))
  293.      (article-brackets nil)
  294.      (article (url-filename urlobj)))
  295.     (url-news-open-host host port (url-user urlobj) (url-password urlobj))
  296.     (cond
  297.      ((string-match "@" article)    ; Its a specific article
  298.       (url-news-fetch-message-id host port article))
  299.      ((string-match "/\\([0-9]+\\)$" article)
  300.       (url-news-fetch-article-number (substring article 0
  301.                         (match-beginning 0))
  302.                      (match-string 1 article)))
  303.                         
  304.      ((string= article "")        ; List all newsgroups
  305.       (gnus)
  306.       (kill-buffer url-working-buffer))
  307.      (t                    ; Whole newsgroup
  308.       (url-news-fetch-newsgroup article)))))
  309.  
  310. (provide 'url-news)
  311.